perm filename MSFILL.F4[Y,MUS] blob
sn#068306 filedate 1973-12-01 generic text, type T, neo UTF8
00100 SUBROUTINE FILLER(IFILL,QJB,QCENT,BX,BY)
00300 DIMENSION IFILL(1)
00400 COMMON /DL/IXRX,SAVER,NAME
00500 COMMON /SIZ/RSZ,JCEN,KCEN
00700 COMMON /FL/IC,N,NQ,RZ,XGP
00800 COMMON /STF/RSTFAC(8),RSTJC
00900 COMMON /PLTR/IPLT,RHT,DIS
01000 COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
01200 EQUIVALENCE (RXGP,WDS(250))
01300 DATA RC/1./
01400 PX=1
01420 IF(BX.EQ.0)BX=1
01440 IF(BY.EQ.0)BY=1
01470 IF(BX)PX=-1
01500 IXGP=XGP
01600 RSI=RSTJC*BY
01700 C RI IS INVERSION FACTOR
01830 BZ=BY/BX
01840 RT=RSTJC*BX
01860 C RS=HORIZ. RT=VERT.
01900 JXGP=RXGP
02000 NX=2
02100 C NX IS POINTER IN X ARRAY
02200 ID=IFILL(NX)
02400 IF(IPLT)GO TO 101
02500 RBZ=QJB*RSZ
02600 RXX=RSZ*RT
02620 C WHAT ABOUT RXX????????
02700 RYX=QCENT*RSZ
02800 RXY=RSI*RSZ
02900 GO TO 100
03000 101 RXX=RT*DIS
03100 RXY=RSI*RHT
03200 RBZ=QJB*DIS
03300 RYX=QCENT*RHT
03400 100 RM=-1000
03450 IF(PX)RM=-RM
03500 I=NX+1
03600 103 CALL UNPACK(IA,IB,IFILL(I))
03700 IF(IA.NE.IFILL(I+1)/10000)GO TO 102
03800 I=I+1
03900 GO TO 103
04000 102 G=IA*RT+QJB
04100 H=IB*RSI+QCENT
04200 IF(IPLT)GO TO 200
04300 CALL LINES(G,H,3)
04400 GO TO 300
04500 200 IF(IXRX.EQ.0)GO TO 90
04600 M=ROFF(-H*RHT+RXGP)
04700 N=ROFF(G*DIS+XGP)
04800 GO TO 80
04900 90 M=ROFF(G*DIS)
05000 N=ROFF(H*RHT)
05100 80 CALL PLOT(M,N,3)
05200 300 NN=ID-1
05300 C LAST OF ARRAY-1
05400 P=IA*RXX
05500 CALL UNPACK(IG,H,IFILL(I+1))
05600 RB=IG*RXX+PX
05700 J=1
05800 1 JJ=1
05850 IF(PX)GO TO 30
05900 IF(RM.GT.RB)GO TO 13
05950 GO TO 31
05960 30 IF(RM.LT.RB)GO TO 13
06000 31 IF(J)GO TO 2
06100 3 CALL NNN(NN,1,0,IFILL)
06200 C FINDS BOTTOM POINTER
06300 GO TO 16
06400 2 CALL NNN(I,0,1,IFILL)
06500 C FINDS TOP POINTER(I)
06600 16 CALL UNPACK(JAX,JB,IFILL(N))
06700 CALL UNPACK(JG,JH,IFILL(N+1))
06800 CALL UNPACK(IQ,H,IFILL(NQ))
06900 RZ=RZ*RXX
06905 10 RDIS=JAX-JG
06910 IF(PX)GO TO 32
07000 IF(P.GT.RZ)P=RZ
07010 GO TO 33
07020 32 IF(P.LT.RZ)P=RZ
07095 C REVERSES VERT.
07100 33 Q=IQ*RXX
07200 C=IC*RXY+RYX
07400 IF(RDIS.NE.0)GO TO 6
07500 C FOR STRAIIGHT UP-DOWN LINES
07600 IF(NN-1.EQ.I)GO TO 13
07700 P=P-PX
07800 GO TO 5
07900 6 H=BZ*(JB-JH)/RDIS
08000 11 HH=(P-Q)*H+C
08100 PP=P+RBZ
08200 IH=ROFF(HH)
08300 IP=ROFF(PP)
08400 C ROFF IS FOR ROUND-OFF ERRORS
08500 IF(IP.EQ.MP.AND.IH.EQ.MH)GO TO 180
08600 MP=IP
08700 MH=IH
08800 C OMITS REPEATED POINTS
08900 IF(IPLT)GO TO 17
09000 CC IF(RSZ.LE.0.8571)GO TO 34
09100 CC IP=IP-JCEN
09200 CC IH=IH-KCEN
09300 CC34 CALL AVECT(IP,IH)
09350 CALL LINES(PP/RSZ,HH/RSZ,2)
09400 GO TO 180
09500 17 IF(IXRX.EQ.0)GO TO 19
09600 K=IP
09700 IP=-IH+JXGP
09800 C NO RNDOFF OR DIS-RHT FACTORS HERE YET.
09900 IH=K+IXGP
10000 19 CALL PLOT(IP,IH,2)
10100 180 JJ=JJ-1
10200 IF(JJ)GO TO 12
10300 RM=P
10400 P=P+PX
10410 IF(PX)GO TO 35
10500 IF(P.LT.RZ)GO TO 11
10510 GO TO 5
10520 35 IF(P.GT.RZ)GO TO 11
10600 5 IF(J)GO TO 4
10700 NN=NN-1
10800 IF(I.GT.NN)GO TO 13
10920 GO TO 3
11000 4 I=I+1
11100 IF(I.GT.NN)GO TO 13
11200 402 CALL UNPACK(IA,IB,IFILL(I+1))
11300 RB=IA*RXX+PX
11400 GO TO 2
11500 12 J=-J
11600 GO TO 1
11700 13 NX=ID+1
11800 IF(ID.EQ.IFILL(1))GO TO 130
11900 ID=IFILL(NX)
12000 GO TO 100
12200 130 MP=1000
12300 MH=1000
12400 RETURN
12500 END
12600
12700 SUBROUTINE NNN(J,L,K,IFILL)
12800 COMMON /FL/IC,N,NQ,RZ,XGP
12900 DIMENSION IFILL(1)
13000 CALL UNPACK(IZ,IC,IFILL(J+K))
13100 CALL UNPACK(N,IC,IFILL(J+L))
13200 N=J
13300 C C IS THE CONSTANT
13400 NQ=N+L
13500 RZ=IZ
13600 RETURN
13700 END
13800
13900 SUBROUTINE UNPACK(M,N,I)
14000 COMMON/LL/L
14100 C L IS FOR VIS. OR INVIS. LINES.
14200 N=I
14300 L=2
14400 IF(N.LT.100000000)GO TO 2
14500 L=3
14600 N=N-100000000
14700 2 M=N/10000
14800 N=N-M*10000
14900 IF(M.GT.1000)M=1000-M
15000 IF(N.GT.1000)N=1000-N
15100 RETURN
15200 END
15300
15400 FUNCTION ROFF(R)
15500 S=.5
15600 IF(R)S=-S
15700 ROFF=R+S
15800 RETURN
15900 END